Figures and tables based on ideo motive analyses (secondary)

Preparations

Load models

# pol models (across performance and neutral)
m1.pol <- readRDS(file = here(pol_model_dir, "m1.pol.rds"))
m2.pol <- readRDS(file = here(pol_model_dir, "m2.pol.rds"))
m3.pol <- readRDS(file = here(pol_model_dir, "m3.pol.rds"))
m4.pol <- readRDS(file = here(pol_model_dir, "m4.pol.rds"))
m5.pol <- readRDS(file = here(pol_model_dir, "m5.pol.rds"))
m6.pol <- readRDS(file = here(pol_model_dir, "m6.pol.rds"))

# performance models
m1.per <- readRDS(file = here(nonpol_model_dir, "m1.per.rds"))
m2.per <- readRDS(file = here(nonpol_model_dir, "m2.per.rds"))
m3.per <- readRDS(file = here(nonpol_model_dir, "m3.per.rds"))
m4.per <- readRDS(file = here(nonpol_model_dir, "m4.per.rds"))
m5.per <- readRDS(file = here(nonpol_model_dir, "m5.per.rds"))
m6.per <- readRDS(file = here(nonpol_model_dir, "m6.per.rds"))

# neutral models
m1.neu <- readRDS(file = here(nonpol_model_dir, "m1.neu.rds"))
m2.neu <- readRDS(file = here(nonpol_model_dir, "m2.neu.rds"))
m3.neu <- readRDS(file = here(nonpol_model_dir, "m3.neu.rds"))
m4.neu <- readRDS(file = here(nonpol_model_dir, "m4.neu.rds"))
m5.neu <- readRDS(file = here(nonpol_model_dir, "m5.neu.rds"))
m6.neu <- readRDS(file = here(nonpol_model_dir, "m6.neu.rds"))

Load original data

data_path <- here("01_data", "analysis", "data_analysis.RData")
load(file = data_path)

Filters

initial_rows <- nrow(data_analysis)
data_prep <- data_analysis %>% 
  filter(Screen != "Question")
filtered_rows <- initial_rows - nrow(data_prep)

filtered_rows
[1] 5389
data_full <- data_prep %>% 
  filter(question_type %in% c("political", "performance", "nonpolitical")) %>% 
  mutate(question_topic = factor(question_topic, 
                                 levels = c("climate",
                                            "gender",
                                            "immigration",
                                            "discrimination",
                                            "adoption",
                                            "punishment",
                                            "gonogo_performance", 
                                            "fakenews_performance",
                                            "teaculture",
                                            "brain"))) %>%
  droplevels()   

unique(data_full$question_topic)
 [1] adoption             climate              punishment           gender              
 [5] discrimination       gonogo_performance   immigration          teaculture          
 [9] fakenews_performance brain               
10 Levels: climate gender immigration discrimination adoption ... brain

Data types

data_full <- data_full %>%
  mutate(ideo_motive_strength = factor(ideo_motive_strength,
                                        levels = c("Anti-strong",
                                                   "Anti-moderate",
                                                   "Anti-weak",
                                                   "Neutral",
                                                   "Pro-weak",
                                                   "Pro-moderate",
                                                   "Pro-strong"),
                                        ordered = TRUE)) 

Data for submodels

data_pol <- data_full %>% 
  filter(question_type == "political") %>% 
  droplevels() 

data_per <- data_full %>% 
  filter(question_type == "performance") %>% 
  droplevels()   

data_neu <- data_full %>% 
  filter(question_type == "nonpolitical") %>% 
  droplevels()  

unique(data_pol$question_topic)
[1] adoption       climate        punishment     gender         discrimination
[6] immigration   
Levels: climate gender immigration discrimination adoption punishment
unique(data_per$question_topic)
[1] gonogo_performance   fakenews_performance
Levels: gonogo_performance fakenews_performance
unique(data_neu$question_topic)
[1] teaculture brain     
Levels: teaculture brain

Table 1: Parameter estimates of interest m1, m3, m4 (logit)

Create a logit table with main parameters of interest of m1, m3, m4.

m1 table

h0a.pol <- hypothesis(m1.pol, "ideo_motivePro > 0",
                      alpha = 0.025,
                      seed = 42)

h0a.per <- hypothesis(m1.per, "ideo_motivePro > 0",
                      alpha = 0.025,
                      seed = 42)

h0a.neu <- hypothesis(m1.neu, "ideo_motivePro > 0",
                      alpha = 0.025,
                      seed = 42)

h0a.pol$hypothesis$Evid.Ratio
[1] 54.2
h0a.per$hypothesis$Evid.Ratio
[1] 7999
h0a.neu$hypothesis$Evid.Ratio
[1] 1.05
h0b.pol <- hypothesis(m1.pol, "ideo_motivePro < 0",
                      alpha = 0.025,
                      seed = 42)

h0b.per <- hypothesis(m1.per, "ideo_motivePro < 0",
                      alpha = 0.025,
                      seed = 42)

h0b.neu <- hypothesis(m1.neu, "ideo_motivePro < 0",
                      alpha = 0.025,
                      seed = 42)

h0b.pol$hypothesis$Evid.Ratio
[1] 0.0185
h0b.per$hypothesis$Evid.Ratio
[1] 0.000125
h0b.neu$hypothesis$Evid.Ratio
[1] 0.95
m1.pol.logit <- describe_posterior(m1.pol, centrality = "median",
                                  ci = 0.95, ci_method = "eti",
                                  diagnostic = c("Rhat"), effects = c("fixed"),
                                  dispersion = FALSE, test = NULL) %>% 
  mutate("Question Type" = "Political") %>% 
  mutate("β > 0" = h0a.pol$hypothesis$Evid.Ratio,
         "β < 0" = h0b.pol$hypothesis$Evid.Ratio)

m1.per.logit <- describe_posterior(m1.per, centrality = "median",
                                  ci = 0.95, ci_method = "eti",
                                  diagnostic = c("Rhat"), effects = c("fixed"),
                                  dispersion = FALSE, test = NULL) %>% 
  mutate("Question Type" = "Performance") %>% 
  mutate("β > 0" = h0a.per$hypothesis$Evid.Ratio,
         "β < 0" = h0b.per$hypothesis$Evid.Ratio)

m1.neu.logit <- describe_posterior(m1.neu, centrality = "median",
                                  ci = 0.95, ci_method = "eti",
                                  diagnostic = c("Rhat"), effects = c("fixed"),
                                  dispersion = FALSE, test = NULL) %>% 
  mutate("Question Type" = "Neutral") %>% 
  mutate("β > 0" = h0a.neu$hypothesis$Evid.Ratio,
         "β < 0" = h0b.neu$hypothesis$Evid.Ratio)

m1.logit <- bind_rows(m1.pol.logit, m1.per.logit, m1.neu.logit) %>% 
  select("Question Type", Parameter, Median, 
         CI_low, CI_high, "β > 0", "β < 0") %>% 
  rename("LL" = CI_low,
         "UL" = CI_high) %>% 
  filter(Parameter == "b_ideo_motivePro") %>% 
  mutate(Parameter = "Motive (Pro > Anti)") %>% 
  mutate(across(where(is.numeric), ~ round(.x, 3)))

m1.logit
Summary of Posterior Distribution

Question Type |           Parameter |   Median |    LL |   UL |   β > 0 | β < 0
-------------------------------------------------------------------------------
Political     | Motive (Pro > Anti) |     0.22 |  0.03 | 0.41 |   54.17 |  0.02
Performance   | Motive (Pro > Anti) |     0.22 |  0.10 | 0.34 | 7999.00 |  0.00
Neutral       | Motive (Pro > Anti) | 2.00e-03 | -0.14 | 0.14 |    1.05 |  0.95

m3 table

h1a.pol <- hypothesis(m3.pol, "ideo_motivePro:scalecrt_correct > 0",
                                alpha = 0.025,
                                seed = 42)

h1a.per <- hypothesis(m3.per, "ideo_motivePro:scalecrt_correct > 0", 
                      alpha = 0.025,
                      seed = 42)

h1a.neu <- hypothesis(m3.neu, "ideo_motivePro:scalecrt_correct > 0", 
                      alpha = 0.025,
                      seed = 42)

h1a.pol$hypothesis$Evid.Ratio
[1] 0.94
h1a.per$hypothesis$Evid.Ratio
[1] 19.6
h1a.neu$hypothesis$Evid.Ratio
[1] 0.955
h1b.pol <- hypothesis(m3.pol, "ideo_motivePro:scalecrt_correct < 0",
                      alpha = 0.025,
                      seed = 42)

h1b.per <- hypothesis(m3.per, "ideo_motivePro:scalecrt_correct < 0", 
                      alpha = 0.025,
                      seed = 42)

h1b.neu <- hypothesis(m3.neu, "ideo_motivePro:scalecrt_correct < 0", 
                      alpha = 0.025,
                      seed = 42)

h1b.pol$hypothesis$Evid.Ratio
[1] 1.06
h1b.per$hypothesis$Evid.Ratio
[1] 0.0511
h1b.neu$hypothesis$Evid.Ratio
[1] 1.05
m3.pol.logit <- describe_posterior(m3.pol, centrality = "median",
                                   ci = 0.95, ci_method = "eti",
                                   diagnostic = c("Rhat"), effects = c("fixed"),
                                   dispersion = FALSE, test = NULL) %>% 
  mutate("Question Type" = "Political") %>% 
  mutate("β > 0" = h1a.pol$hypothesis$Evid.Ratio,
         "β < 0" = h1b.pol$hypothesis$Evid.Ratio)

m3.per.logit <- describe_posterior(m3.per, centrality = "median",
                                   ci = 0.95, ci_method = "eti",
                                   diagnostic = c("Rhat"), effects = c("fixed"),
                                   dispersion = FALSE, test = NULL) %>% 
  mutate("Question Type" = "Performance") %>% 
  mutate("β > 0" = h1a.per$hypothesis$Evid.Ratio,
         "β < 0" = h1b.per$hypothesis$Evid.Ratio)

m3.neu.logit <- describe_posterior(m3.neu, centrality = "median",
                                   ci = 0.95, ci_method = "eti",
                                   diagnostic = c("Rhat"), effects = c("fixed"),
                                   dispersion = FALSE, test = NULL) %>% 
  mutate("Question Type" = "Neutral") %>% 
  mutate("β > 0" = h1a.neu$hypothesis$Evid.Ratio,
         "β < 0" = h1b.neu$hypothesis$Evid.Ratio)

m3.logit <- bind_rows(m3.pol.logit, m3.per.logit, m3.neu.logit) %>% 
  select("Question Type", Parameter, Median, 
         CI_low, CI_high, "β > 0", "β < 0") %>% 
  rename("LL" = CI_low,
         "UL" = CI_high) %>% 
  filter(Parameter == "b_ideo_motivePro:scalecrt_correct") %>% 
  mutate(Parameter = "Motive x Cognitive Reflection") %>% 
  mutate(across(where(is.numeric), ~ round(.x, 3)))

m3.logit
Summary of Posterior Distribution

Question Type |                     Parameter |    Median |    LL |   UL | β > 0 | β < 0
----------------------------------------------------------------------------------------
Political     | Motive x Cognitive Reflection | -2.00e-03 | -0.07 | 0.07 |  0.94 |  1.06
Performance   | Motive x Cognitive Reflection |      0.11 | -0.02 | 0.23 | 19.57 |  0.05
Neutral       | Motive x Cognitive Reflection | -2.00e-03 | -0.14 | 0.14 |  0.95 |  1.05

m4 table

h2a.pol <- hypothesis(m4.pol, "ideo_motivePro:scalecommission_errors_r > 0",
                      alpha = 0.025,
                      seed = 42)

h2a.per <- hypothesis(m4.per, "ideo_motivePro:scalecommission_errors_r > 0", 
                      alpha = 0.025,
                      seed = 42)

h2a.neu <- hypothesis(m4.neu, "ideo_motivePro:scalecommission_errors_r > 0",
                      alpha = 0.025,
                      seed = 42)

h2a.pol$hypothesis$Evid.Ratio
[1] 1.17
h2a.per$hypothesis$Evid.Ratio
[1] 72.4
h2a.neu$hypothesis$Evid.Ratio
[1] 1.19
h2b.pol <- hypothesis(m4.pol, "ideo_motivePro:scalecommission_errors_r < 0",
                      alpha = 0.025,
                      seed = 42)

h2b.per <- hypothesis(m4.per, "ideo_motivePro:scalecommission_errors_r < 0", 
                      alpha = 0.025,
                      seed = 42)

h2b.neu <- hypothesis(m4.neu, "ideo_motivePro:scalecommission_errors_r < 0",
                      alpha = 0.025,
                      seed = 42)

h2b.pol$hypothesis$Evid.Ratio
[1] 0.855
h2b.per$hypothesis$Evid.Ratio
[1] 0.0138
h2b.neu$hypothesis$Evid.Ratio
[1] 0.839
m4.pol.logit <- describe_posterior(m4.pol, centrality = "median",
                                   ci = 0.95, ci_method = "eti",
                                   diagnostic = c("Rhat"), effects = c("fixed"),
                                   dispersion = FALSE, test = NULL) %>% 
  mutate("Question Type" = "Political") %>% 
  mutate("β > 0" = h2a.pol$hypothesis$Evid.Ratio,
         "β < 0" = h2b.pol$hypothesis$Evid.Ratio)

m4.per.logit <- describe_posterior(m4.per, centrality = "median",
                                   ci = 0.95, ci_method = "eti",
                                   diagnostic = c("Rhat"), effects = c("fixed"),
                                   dispersion = FALSE, test = NULL) %>% 
  mutate("Question Type" = "Performance") %>% 
  mutate("β > 0" = h2a.per$hypothesis$Evid.Ratio,
         "β < 0" = h2b.per$hypothesis$Evid.Ratio)

m4.neu.logit <- describe_posterior(m4.neu, centrality = "median",
                                   ci = 0.95, ci_method = "eti",
                                   diagnostic = c("Rhat"), effects = c("fixed"),
                                   dispersion = FALSE, test = NULL) %>% 
  mutate("Question Type" = "Neutral") %>% 
  mutate("β > 0" = h2a.neu$hypothesis$Evid.Ratio,
         "β < 0" = h2b.neu$hypothesis$Evid.Ratio)

m4.logit <- bind_rows(m4.pol.logit, m4.per.logit, m4.neu.logit) %>% 
  select("Question Type", Parameter, Median, 
         CI_low, CI_high, "β > 0", "β < 0") %>% 
  rename("LL" = CI_low,
         "UL" = CI_high) %>% 
  filter(Parameter == "b_ideo_motivePro:scalecommission_errors_r") %>% 
  mutate(Parameter = "Motive x Inhibitory Control") %>% 
  mutate(across(where(is.numeric), ~ round(.x, 3)))

m4.logit
Summary of Posterior Distribution

Question Type |                   Parameter |   Median |    LL |   UL | β > 0 | β < 0
-------------------------------------------------------------------------------------
Political     | Motive x Inhibitory Control | 4.00e-03 | -0.07 | 0.08 |  1.17 |  0.85
Performance   | Motive x Inhibitory Control |     0.14 |  0.01 | 0.26 | 72.39 |  0.01
Neutral       | Motive x Inhibitory Control | 8.00e-03 | -0.13 | 0.14 |  1.19 |  0.84

Combined table

combined_logit <- bind_rows(m1.logit, m3.logit, m4.logit) %>% 
  mutate(`Question Type` = factor(`Question Type`, levels = c("Political", "Performance", "Neutral"))) %>% 
  arrange(`Question Type`, Parameter)

combined_logit_table <- combined_logit %>% 
  select(-c("Question Type")) %>% 
  tt() %>% 
  group_tt(
    i = list(
      "Political Vignettes" = 1,
      "Performance Vignettes" = 4,
      "Neutral Vignettes" = 7
    ),
    j = list(
      "95% CI" = 3:4,
      "Evidence Ratio" = 5:6))

combined_logit_table %>% save_tt(here(table_dir, "combined_logit_table.docx"), overwrite = TRUE)

combined_logit_table
tinytable_lu5jexmbp01nxordx1uv
95% CI Evidence Ratio
Parameter Median LL UL β > 0 β < 0
Motive (Pro > Anti) 0.220 0.027 0.410 54.172 0.018
Motive x Cognitive Reflection -0.002 -0.074 0.072 0.940 1.064
Motive x Inhibitory Control 0.004 -0.069 0.076 1.169 0.855
Motive (Pro > Anti) 0.221 0.100 0.345 7999.000 0.000
Motive x Cognitive Reflection 0.108 -0.019 0.230 19.566 0.051
Motive x Inhibitory Control 0.140 0.014 0.263 72.394 0.014
Motive (Pro > Anti) 0.002 -0.136 0.140 1.053 0.950
Motive x Cognitive Reflection -0.002 -0.136 0.138 0.955 1.048
Motive x Inhibitory Control 0.008 -0.128 0.141 1.192 0.839

Main Text: Reported Percentage Predictions m1, m3

m1: Pro vs. Anti in %

Calculate % comparisons

m1.pol.com <- m1.pol %>% 
  avg_comparisons() %>% 
  as_tibble() %>% 
  select(contrast, estimate, conf.low, conf.high) %>%
  filter(contrast == "mean(Pro) - mean(Anti)") %>% 
  mutate(contrast = recode(contrast,
                           "mean(Pro) - mean(Anti)" = "Pro - Anti"),
         "Question Type" = "Political") %>%
  rename("Contrast" = "contrast",
         "Estimate" = "estimate",
         "LL" = "conf.low",
         "UL" = "conf.high")
m1.per.com <- m1.per %>% 
  avg_comparisons() %>% 
  as_tibble() %>% 
  select(contrast, estimate, conf.low, conf.high) %>%
  filter(contrast == "mean(Pro) - mean(Anti)") %>% 
  mutate(contrast = recode(contrast,
                           "mean(Pro) - mean(Anti)" = "Pro - Anti"),
         "Question Type" = "Performance") %>%
  rename("Contrast" = "contrast",
         "Estimate" = "estimate",
         "LL" = "conf.low",
         "UL" = "conf.high")
m1.neu.com <- m1.neu %>% 
  avg_comparisons() %>% 
  as_tibble() %>% 
  select(contrast, estimate, conf.low, conf.high) %>%
  filter(contrast == "mean(Pro) - mean(Anti)") %>% 
  mutate(contrast = recode(contrast,
                           "mean(Pro) - mean(Anti)" = "Pro - Anti"),
         "Question Type" = "Neutral") %>%
  rename("Contrast" = "contrast",
         "Estimate" = "estimate",
         "LL" = "conf.low",
         "UL" = "conf.high")

Combined table

m1.combined_perc <- bind_rows(m1.pol.com, m1.per.com, m1.neu.com) %>% 
  mutate(`Question Type` = factor(`Question Type`, levels = c("Political", "Performance", "Neutral"))) 

m1.combined_perc_table <- m1.combined_perc %>% 
  select(-c("Question Type")) %>% 
  tt() %>% 
  group_tt(
    i = list(
      "Political Vignettes" = 1,
      "Performance Vignettes" = 2,
      "Neutral Vignettes" = 3
    ),
    j = list(
      "95% CI" = 3:4))

m1.combined_perc_table %>% save_tt(here(table_dir, "m1_combined_perc_table.docx"), overwrite = TRUE)

m1.combined_perc_table
tinytable_aacxedprhgxbtyjpo7jr
95% CI
Contrast Estimate LL UL
Pro - Anti 0.05602 0.0383 0.0736
Pro - Anti 0.05612 0.0264 0.0859
Pro - Anti -0.00334 -0.0370 0.0307

m3: Pro vs. Anti for CRT = 3 and CRT = 0 in %

crt.newdata <- 
  expand_grid(ideo_motive = c("Pro", "Anti"),
              crt_correct = c(0, 3))
m3.pol.com <- m3.pol %>%
    epred_draws(newdata = crt.newdata,
                re_formula = NA) %>% 
    group_by(crt_correct) %>% 
    compare_levels(.epred, by = ideo_motive) %>% 
    compare_levels(.epred, by = crt_correct) %>% 
    median_qi(.width = 0.95)
m3.pol.com %>% tt()
tinytable_8lq7i6pf7mkfusq9jhf7
crt_correct ideo_motive .epred .lower .upper .width .point .interval
3 - 0 Pro - Anti -0.00132 -0.0492 0.0472 0.95 median qi

Figure: Motivated Reasoning on Different Topics

Extract draws

Average effect of motivated reasoning on political, performance, and neutral topics

m1.pol.draws <- m1.pol %>%
  avg_comparisons(variables = "ideo_motive") %>% 
  posterior_draws() %>% 
  filter(contrast == "mean(Pro) - mean(Anti)") %>% 
  mutate(question_type = "Political",
         question_topic = "average")

m1.pol.draws %>% median_hdi(draw)
# A tibble: 1 × 6
    draw .lower .upper .width .point .interval
   <dbl>  <dbl>  <dbl>  <dbl> <chr>  <chr>    
1 0.0560 0.0379 0.0730   0.95 median hdi      
m1.per.draws <- m1.per %>%
  avg_comparisons(variables = "ideo_motive") %>% 
  posterior_draws() %>% 
  filter(contrast == "mean(Pro) - mean(Anti)") %>% 
  mutate(question_type = "Performance",
         question_topic = "average")

m1.per.draws %>% median_hdi(draw)
# A tibble: 1 × 6
    draw .lower .upper .width .point .interval
   <dbl>  <dbl>  <dbl>  <dbl> <chr>  <chr>    
1 0.0561 0.0267 0.0860   0.95 median hdi      
m1.neu.draws <- m1.neu %>%
  avg_comparisons(variables = "ideo_motive") %>% 
  posterior_draws() %>% 
  filter(contrast == "mean(Pro) - mean(Anti)") %>% 
  mutate(question_type = "Neutral",
         question_topic = "average")

m1.neu.draws %>% median_hdi(draw)
# A tibble: 1 × 6
      draw  .lower .upper .width .point .interval
     <dbl>   <dbl>  <dbl>  <dbl> <chr>  <chr>    
1 -0.00334 -0.0370 0.0307   0.95 median hdi      

Motivated reasoning by topic

m1.pol.topic <- avg_comparisons(m1.pol,
                                variables = "ideo_motive",
                                by = "question_topic") %>% 
  posterior_draws() %>% 
  filter(contrast == "mean(Pro) - mean(Anti)") %>% 
  mutate(question_type = "Political")
  
m1.pol.topic %>% group_by(question_topic) %>% median_hdi(draw)
# A tibble: 6 × 7
  question_topic   draw  .lower .upper .width .point .interval
  <fct>           <dbl>   <dbl>  <dbl>  <dbl> <chr>  <chr>    
1 climate        0.0545  0.0179 0.0890   0.95 median hdi      
2 gender         0.0244 -0.0139 0.0616   0.95 median hdi      
3 immigration    0.0913  0.0533 0.126    0.95 median hdi      
4 discrimination 0.0871  0.0477 0.127    0.95 median hdi      
5 adoption       0.0597  0.0240 0.0943   0.95 median hdi      
6 punishment     0.0205 -0.0187 0.0590   0.95 median hdi      
m1.per.topic <- avg_comparisons(m1.per,
                                variables = "ideo_motive",
                                by = "question_topic") %>% 
  posterior_draws() %>% 
  filter(contrast == "mean(Pro) - mean(Anti)") %>% 
  mutate(question_type = "Performance")
  
m1.per.topic %>% group_by(question_topic) %>% median_hdi(draw)
# A tibble: 2 × 7
  question_topic         draw  .lower .upper .width .point .interval
  <fct>                 <dbl>   <dbl>  <dbl>  <dbl> <chr>  <chr>    
1 gonogo_performance   0.0665 0.0223  0.106    0.95 median hdi      
2 fakenews_performance 0.0456 0.00326 0.0869   0.95 median hdi      
m1.neu.topic <- avg_comparisons(m1.neu,
                                variables = "ideo_motive",
                                by = "question_topic") %>% 
  posterior_draws() %>% 
  filter(contrast == "mean(Pro) - mean(Anti)") %>% 
  mutate(question_type = "Neutral")
  
m1.neu.topic %>% group_by(question_topic) %>% median_hdi(draw)
# A tibble: 2 × 7
  question_topic    draw   .lower  .upper .width .point .interval
  <fct>            <dbl>    <dbl>   <dbl>  <dbl> <chr>  <chr>    
1 teaculture     -0.0414 -0.0870  0.00307   0.95 median hdi      
2 brain           0.0412 -0.00770 0.0915    0.95 median hdi      

Create a combined dataframe

m1.combined <- bind_rows(m1.pol.draws, m1.pol.topic, 
                         m1.per.draws, m1.per.topic,
                         m1.neu.draws, m1.neu.topic)
m1.combined <- m1.combined %>% 
  mutate(question_topic = factor(question_topic,
                                 levels = c("brain",
                                            "teaculture", 
                                            "fakenews_performance", 
                                            "gonogo_performance",
                                            "punishment",
                                            "adoption", 
                                            "discrimination",
                                            "gender",
                                            "immigration",
                                            "climate", 
                                            "average"),
                                 labels = c("Brain proportion",
                                            "Tea with milk",
                                            "Fake News performance",
                                            "Go / No-Go performance",
                                            "Criminal reconviction",
                                            "Same-sex adoption",
                                            "Racial discrimination",
                                            "Gender stereotypes",
                                            "Immigrant population",
                                            "Anthropogenic climate change",
                                            "Average"
                                            )),
         draw_perc = draw*100) 

Create figure

average_color <- "#645CAA"

plot_political <- m1.combined %>%
  filter(question_type == "Political") %>%
  ggplot(aes(x = draw_perc, y = question_topic, 
             fill = question_topic == "Average")) +
  stat_halfeye(slab_alpha = 0.9, .width = c(0.5, 0.95), 
               point_interval = "median_qi") +
  geom_vline(xintercept = 0, alpha = 0.8, linewidth = 0.8, 
             color = "black", linetype = "dashed") +
  scale_fill_manual(values = c(`TRUE` = average_color, `FALSE` = "#A685E2")) +
  labs(subtitle = "Political Vignettes",
       x = NULL, y = NULL) +
  scale_x_continuous(labels = label_percent(scale = 1), limits = c(-10, 25),
                     breaks = seq(-10, 20, by = 5)) +
  theme_ipsum_rc(base_size = 16,
                 subtitle_size = 18,
                 subtitle_face = "bold",
                 axis_text_size = 16,
                 grid = "XY") +
  guides(fill = "none") +
  theme(legend.position = "none")

plot_performance <- m1.combined %>%
  filter(question_type == "Performance") %>%
  ggplot(aes(x = draw_perc, y = question_topic, 
             fill = question_topic == "Average")) +
  stat_halfeye(slab_alpha = 0.9, .width = c(0.5, 0.95), 
               point_interval = "median_qi") +
  geom_vline(xintercept = 0, alpha = 0.8, linewidth = 0.8, 
             color = "black", linetype = "dashed") +
  scale_fill_manual(values = c(`TRUE` = average_color, `FALSE` = "#FF8DC7")) +
  labs(subtitle = "Performance Vignettes",
       x = NULL, y = NULL) +
  scale_x_continuous(labels = label_percent(scale = 1), limits = c(-10, 25)) +
  theme_ipsum_rc(base_size = 16,
                 subtitle_size = 18,
                 subtitle_face = "bold",
                 axis_text_size = 16,
                 grid = "XY") +
  guides(fill = "none") +
  theme(legend.position = "none")

plot_neutral <- m1.combined %>%
  filter(question_type == "Neutral") %>%
  ggplot(aes(x = draw_perc, y = question_topic, 
             fill = question_topic == "Average")) +
  stat_halfeye(slab_alpha = 0.9, .width = c(0.5, 0.95), 
               point_interval = "median_qi") +
  geom_vline(xintercept = 0, alpha = 0.8, linewidth = 0.8, 
             color = "black", linetype = "dashed") +
  scale_fill_manual(values = c(`TRUE` = average_color, `FALSE` = "#FFABE1")) +
  labs(subtitle = "Neutral Vignettes",
       x = NULL, y = NULL) +
  scale_x_continuous(labels = label_percent(scale = 1), limits = c(-10, 25)) +
  theme_ipsum_rc(base_size = 16,
                 subtitle_size = 18,
                 subtitle_face = "bold",
                 axis_text_size = 16,
                 grid = "XY") +
  guides(fill = "none") +
  theme(legend.position = "none")

main_effect_plot <- plot_political / (plot_performance | plot_neutral) +
  plot_layout(heights = c(2, 1))

main_effect_plot
Warning: Removed 38 rows containing missing values or values outside the scale range
(`stat_slabinterval()`).

ggsave(here(fig_dir, "m1_main_fig.png"), width = 12, height = 10, dpi = 300)
Warning: Removed 38 rows containing missing values or values outside the scale range
(`stat_slabinterval()`).

Supplementary Table 3

Create a logit table with main parameters of interest of m2, m5, m6.

m2 table

h0a_mo.pol <- as_tibble(m2.pol) %>% 
  hypothesis(., "bsp_moideo_motive_strength > 0",
                      alpha = 0.025,
                      seed = 42)


h0a_mo.per <- as_tibble(m2.per) %>% 
  hypothesis(., "bsp_moideo_motive_strength > 0",
                      alpha = 0.025,
                      seed = 42)

h0a_mo.neu <- as_tibble(m2.neu) %>% 
  hypothesis(., "bsp_moideo_motive_strength > 0",
                      alpha = 0.025,
                      seed = 42)

h0a_mo.pol$hypothesis$Evid.Ratio
[1] 92
h0a_mo.per$hypothesis$Evid.Ratio
[1] 614
h0a_mo.neu$hypothesis$Evid.Ratio
[1] 0.541
h0b_mo.pol <- as_tibble(m2.pol) %>% 
  hypothesis(., "bsp_moideo_motive_strength < 0",
             alpha = 0.025,
             seed = 42)


h0b_mo.per <- as_tibble(m2.per) %>% 
  hypothesis(., "bsp_moideo_motive_strength < 0",
             alpha = 0.025,
             seed = 42)

h0b_mo.neu <- as_tibble(m2.neu) %>% 
  hypothesis(., "bsp_moideo_motive_strength < 0",
             alpha = 0.025,
             seed = 42)

h0b_mo.pol$hypothesis$Evid.Ratio
[1] 0.0109
h0b_mo.per$hypothesis$Evid.Ratio
[1] 0.00163
h0b_mo.neu$hypothesis$Evid.Ratio
[1] 1.85
m2.pol.logit <- describe_posterior(m2.pol, centrality = "median",
                                   ci = 0.95, ci_method = "eti",
                                   diagnostic = c("Rhat"), effects = c("fixed"),
                                   dispersion = FALSE, test = NULL) %>% 
  mutate("Question Type" = "Political") %>% 
  mutate("β > 0" = h0a_mo.pol$hypothesis$Evid.Ratio,
         "β < 0" = h0b_mo.pol$hypothesis$Evid.Ratio)

m2.per.logit <- describe_posterior(m2.per, centrality = "median",
                                   ci = 0.95, ci_method = "eti",
                                   diagnostic = c("Rhat"), effects = c("fixed"),
                                   dispersion = FALSE, test = NULL) %>% 
  mutate("Question Type" = "Performance") %>% 
  mutate("β > 0" = h0a_mo.per$hypothesis$Evid.Ratio,
         "β < 0" = h0b_mo.per$hypothesis$Evid.Ratio)

m2.neu.logit <- describe_posterior(m2.neu, centrality = "median",
                                   ci = 0.95, ci_method = "eti",
                                   diagnostic = c("Rhat"), effects = c("fixed"),
                                   dispersion = FALSE, test = NULL) %>% 
  mutate("Question Type" = "Neutral") %>% 
  mutate("β > 0" = h0a_mo.neu$hypothesis$Evid.Ratio,
         "β < 0" = h0b_mo.neu$hypothesis$Evid.Ratio)

m2.logit <- bind_rows(m2.pol.logit, m2.per.logit, m2.neu.logit) %>% 
  select("Question Type", Parameter, Median, 
         CI_low, CI_high, "β > 0", "β < 0") %>% 
  rename("LL" = CI_low,
         "UL" = CI_high) %>% 
  filter(Parameter == "bsp_moideo_motive_strength") %>% 
  mutate(Parameter = "Motive strength") %>% 
  mutate(across(where(is.numeric), ~ round(.x, 3)))

m2.logit
Summary of Posterior Distribution

Question Type |       Parameter |    Median |    LL |   UL |  β > 0 |    β < 0
------------------------------------------------------------------------------
Political     | Motive strength |      0.07 |  0.01 | 0.14 |  92.02 |     0.01
Performance   | Motive strength |      0.06 |  0.02 | 0.12 | 614.38 | 2.00e-03
Neutral       | Motive strength | -8.00e-03 | -0.05 | 0.04 |   0.54 |     1.85

m5 table

h1a_mo.pol <- as_tibble(m5.pol) %>% 
  hypothesis(., "bsp_moideo_motive_strength:scalecrt_correct > 0",
                      alpha = 0.025,
                      seed = 42)

h1a_mo.per <- as_tibble(m5.per) %>% 
  hypothesis(., "bsp_moideo_motive_strength:scalecrt_correct > 0", 
                      alpha = 0.025,
                      seed = 42)

h1a_mo.neu <- as_tibble(m5.neu) %>% 
  hypothesis(., "bsp_moideo_motive_strength:scalecrt_correct > 0", 
                      alpha = 0.025,
                      seed = 42)

h1a_mo.pol$hypothesis$Evid.Ratio
[1] 0.627
h1a_mo.per$hypothesis$Evid.Ratio
[1] 37.8
h1a_mo.neu$hypothesis$Evid.Ratio
[1] 0.684
h1b_mo.pol <- as_tibble(m5.pol) %>% 
  hypothesis(., "bsp_moideo_motive_strength:scalecrt_correct < 0",
             alpha = 0.025,
             seed = 42)

h1b_mo.per <- as_tibble(m5.per) %>% 
  hypothesis(., "bsp_moideo_motive_strength:scalecrt_correct < 0", 
             alpha = 0.025,
             seed = 42)

h1b_mo.neu <- as_tibble(m5.neu) %>% 
  hypothesis(., "bsp_moideo_motive_strength:scalecrt_correct < 0", 
             alpha = 0.025,
             seed = 42)

h1b_mo.pol$hypothesis$Evid.Ratio
[1] 1.59
h1b_mo.per$hypothesis$Evid.Ratio
[1] 0.0264
h1b_mo.neu$hypothesis$Evid.Ratio
[1] 1.46
m5.pol.logit <- describe_posterior(m5.pol, centrality = "median",
                                   ci = 0.95, ci_method = "eti",
                                   diagnostic = c("Rhat"), effects = c("fixed"),
                                   dispersion = FALSE, test = NULL) %>% 
  mutate("Question Type" = "Political") %>% 
  mutate("β > 0" = h1a_mo.pol$hypothesis$Evid.Ratio,
         "β < 0" = h1b_mo.pol$hypothesis$Evid.Ratio)

m5.per.logit <- describe_posterior(m5.per, centrality = "median",
                                   ci = 0.95, ci_method = "eti",
                                   diagnostic = c("Rhat"), effects = c("fixed"),
                                   dispersion = FALSE, test = NULL) %>% 
  mutate("Question Type" = "Performance") %>% 
  mutate("β > 0" = h1a_mo.per$hypothesis$Evid.Ratio,
         "β < 0" = h1b_mo.per$hypothesis$Evid.Ratio)

m5.neu.logit <- describe_posterior(m5.neu, centrality = "median",
                                   ci = 0.95, ci_method = "eti",
                                   diagnostic = c("Rhat"), effects = c("fixed"),
                                   dispersion = FALSE, test = NULL) %>% 
  mutate("Question Type" = "Neutral") %>% 
  mutate("β > 0" = h1a_mo.neu$hypothesis$Evid.Ratio,
         "β < 0" = h1b_mo.neu$hypothesis$Evid.Ratio)

m5.logit <- bind_rows(m5.pol.logit, m5.per.logit, m5.neu.logit) %>% 
  select("Question Type", Parameter, Median, 
         CI_low, CI_high, "β > 0", "β < 0") %>% 
  rename("LL" = CI_low,
         "UL" = CI_high) %>% 
  filter(Parameter == "bsp_moideo_motive_strength:scalecrt_correct") %>% 
  mutate(Parameter = "Motive strength x Cognitive Reflection") %>% 
  mutate(across(where(is.numeric), ~ round(.x, 3)))

m5.logit
Summary of Posterior Distribution

Question Type |                              Parameter |    Median |    LL |   UL | β > 0 | β < 0
-------------------------------------------------------------------------------------------------
Political     | Motive strength x Cognitive Reflection | -3.00e-03 | -0.03 | 0.02 |  0.63 |  1.59
Performance   | Motive strength x Cognitive Reflection |      0.05 |  0.00 | 0.12 | 37.84 |  0.03
Neutral       | Motive strength x Cognitive Reflection | -5.00e-03 | -0.05 | 0.04 |  0.68 |  1.46

m6 table

h2a_mo.pol <- as_tibble(m6.pol) %>% 
  hypothesis(., "bsp_moideo_motive_strength:scalecommission_errors_r > 0",
                      alpha = 0.025,
                      seed = 42)

h2a_mo.per <- as_tibble(m6.per) %>% 
  hypothesis(., "bsp_moideo_motive_strength:scalecommission_errors_r > 0", 
                      alpha = 0.025,
                      seed = 42)

h2a_mo.neu <- as_tibble(m6.neu) %>% 
  hypothesis(., "bsp_moideo_motive_strength:scalecommission_errors_r > 0",
                      alpha = 0.025,
                      seed = 42)

h2a_mo.pol$hypothesis$Evid.Ratio
[1] 0.761
h2a_mo.per$hypothesis$Evid.Ratio
[1] 28.7
h2a_mo.neu$hypothesis$Evid.Ratio
[1] 0.169
h2b_mo.pol <- as_tibble(m6.pol) %>% 
  hypothesis(., "bsp_moideo_motive_strength:scalecommission_errors_r < 0",
             alpha = 0.025,
             seed = 42)

h2b_mo.per <- as_tibble(m6.per) %>% 
  hypothesis(., "bsp_moideo_motive_strength:scalecommission_errors_r < 0", 
             alpha = 0.025,
             seed = 42)

h2b_mo.neu <- as_tibble(m6.neu) %>% 
  hypothesis(., "bsp_moideo_motive_strength:scalecommission_errors_r < 0",
             alpha = 0.025,
             seed = 42)

h2b_mo.pol$hypothesis$Evid.Ratio
[1] 1.31
h2b_mo.per$hypothesis$Evid.Ratio
[1] 0.0348
h2b_mo.neu$hypothesis$Evid.Ratio
[1] 5.93
m6.pol.logit <- describe_posterior(m6.pol, centrality = "median",
                                   ci = 0.95, ci_method = "eti",
                                   diagnostic = c("Rhat"), effects = c("fixed"),
                                   dispersion = FALSE, test = NULL) %>% 
  mutate("Question Type" = "Political") %>% 
  mutate("β > 0" = h2a_mo.pol$hypothesis$Evid.Ratio,
         "β < 0" = h2b_mo.pol$hypothesis$Evid.Ratio)

m6.per.logit <- describe_posterior(m6.per, centrality = "median",
                                   ci = 0.95, ci_method = "eti",
                                   diagnostic = c("Rhat"), effects = c("fixed"),
                                   dispersion = FALSE, test = NULL) %>% 
  mutate("Question Type" = "Performance") %>% 
  mutate("β > 0" = h2a_mo.per$hypothesis$Evid.Ratio,
         "β < 0" = h2b_mo.per$hypothesis$Evid.Ratio)

m6.neu.logit <- describe_posterior(m6.neu, centrality = "median",
                                   ci = 0.95, ci_method = "eti",
                                   diagnostic = c("Rhat"), effects = c("fixed"),
                                   dispersion = FALSE, test = NULL) %>% 
  mutate("Question Type" = "Neutral") %>% 
  mutate("β > 0" = h2a_mo.neu$hypothesis$Evid.Ratio,
         "β < 0" = h2a_mo.neu$hypothesis$Evid.Ratio)

m6.logit <- bind_rows(m6.pol.logit, m6.per.logit, m6.neu.logit) %>% 
  select("Question Type", Parameter, Median, 
         CI_low, CI_high, "β > 0", "β < 0") %>% 
  rename("LL" = CI_low,
         "UL" = CI_high) %>% 
  filter(Parameter == "bsp_moideo_motive_strength:scalecommission_errors_r") %>% 
  mutate(Parameter = "Motive strength x Inhibitory Control") %>% 
  mutate(across(where(is.numeric), ~ round(.x, 3)))

m6.logit
Summary of Posterior Distribution

Question Type |                            Parameter |    Median |        LL |   UL | β > 0 | β < 0
---------------------------------------------------------------------------------------------------
Political     | Motive strength x Inhibitory Control | -2.00e-03 |     -0.03 | 0.02 |  0.76 |  1.31
Performance   | Motive strength x Inhibitory Control |      0.05 | -4.00e-03 | 0.11 | 28.74 |  0.04
Neutral       | Motive strength x Inhibitory Control |     -0.03 |     -0.09 | 0.02 |  0.17 |  0.17

Combined table

combined_mo_logit <- bind_rows(m2.logit, m5.logit, m6.logit) %>% 
  mutate(`Question Type` = factor(`Question Type`, levels = c("Political", "Performance", "Neutral"))) %>% 
  arrange(`Question Type`, Parameter)

combined_mo_logit_table <- combined_mo_logit %>% 
  select(-c("Question Type")) %>% 
  tt() %>% 
  group_tt(
    i = list(
      "Political Vignettes" = 1,
      "Performance Vignettes" = 4,
      "Neutral Vignettes" = 7
    ),
    j = list(
      "95% CI" = 3:4,
      "Evidence Ratio" = 5:6))

combined_mo_logit_table %>% save_tt(here(table_dir, "combined_mo_logit_table.docx"), overwrite = TRUE)

combined_mo_logit_table
tinytable_l2faes0hv47j9hggs0di
95% CI Evidence Ratio
Parameter Median LL UL β > 0 β < 0
Motive strength 0.068 0.012 0.135 92.023 0.011
Motive strength x Cognitive Reflection -0.003 -0.031 0.019 0.627 1.595
Motive strength x Inhibitory Control -0.002 -0.030 0.019 0.761 1.314
Motive strength 0.063 0.021 0.124 614.385 0.002
Motive strength x Cognitive Reflection 0.052 0.000 0.124 37.835 0.026
Motive strength x Inhibitory Control 0.046 -0.004 0.109 28.740 0.035
Motive strength -0.008 -0.053 0.039 0.541 1.849
Motive strength x Cognitive Reflection -0.005 -0.047 0.042 0.684 1.463
Motive strength x Inhibitory Control -0.025 -0.087 0.020 0.169 0.169

Supplementary Figure 2

Extract draws

m2.pol.draws <- m2.pol %>% 
  epred_draws(newdata = expand_grid(ideo_motive_strength = c("Anti-strong",
                                                   "Anti-moderate",
                                                   "Anti-weak",
                                                   "Pro-weak",
                                                   "Pro-moderate",
                                                   "Pro-strong"),
                                    question_topic = levels(data_pol$question_topic)),
              re_formula = ~(ideo_motive|question_topic)) 

m2.per.draws <- m2.per %>% 
  epred_draws(newdata = expand_grid(ideo_motive_strength = c("Anti-strong",
                                                   "Anti-moderate",
                                                   "Anti-weak",
                                                   "Pro-weak",
                                                   "Pro-moderate",
                                                   "Pro-strong"),
                               question_topic = levels(data_per$question_topic)),
              re_formula = NA) 


m2.neu.draws <- m2.neu %>% 
  epred_draws(newdata = expand_grid(ideo_motive_strength = c("Anti-strong",
                                                   "Anti-moderate",
                                                   "Anti-weak",
                                                   "Pro-weak",
                                                   "Pro-moderate",
                                                   "Pro-strong"),
                               question_topic = levels(data_neu$question_topic)),
              re_formula = NA) 
m2.draws <- bind_rows(m2.pol.draws, m2.per.draws, m2.neu.draws) %>% 
  mutate(ideo_motive_strength = factor(ideo_motive_strength,
                                        levels = c("Anti-strong",
                                                   "Anti-moderate",
                                                   "Anti-weak",
                                                   "Pro-weak",
                                                   "Pro-moderate",
                                                   "Pro-strong"),
                                        ordered = TRUE),
         question_topic = factor(question_topic, 
                        levels = c("climate",
                                   "immigration",
                                   "gender",
                                   "discrimination",
                                   "adoption",
                                   "punishment",
                                   "gonogo_performance",
                                   "fakenews_performance",
                                   "teaculture",
                                   "brain"),
                        labels = c("Anthropogenic climate change",
                                   "Immigrant population",
                                   "Gender stereotypes",
                                   "Racial discrimination",
                                   "Same-sex adoption",
                                   "Criminal reconviction",
                                   "Go / No-Go performance",
                                   "Fake News performance",
                                   "Tea with milk",
                                   "Brain proportion")))

Create figure

m2.draws %>% 
  mutate(perc = .epred * 100) %>% 
  ggplot(aes(x = perc, y = ideo_motive_strength, fill = ideo_motive_strength)) +
  stat_halfeye(slab_alpha = 0.9, .width = c(0.5, 0.95), 
               point_interval = "median_qi") +
  geom_vline(xintercept = 50, alpha = 0.8, linewidth = 0.8, 
             color = "black", linetype = "dashed") +
  guides(fill = "none") +
  scale_fill_manual(values = rev(beyonce_palette(41, n = 6, 
                                             type = "continuous"))) +
  labs(title="Message Ratings by Motive Strength",
       x = "Coefficients", y = NULL,
       caption = "50% and 95% credible intervals shown in black") +
  scale_x_continuous(labels = label_percent(scale = 1), limits = c(15, 85),
                     breaks = seq(20, 80, by = 10)) +
  theme_ipsum_rc(base_size = 12,
                 plot_title_size = 14,
                 axis_title_size = 12,
                 axis_title_face = "bold",
                 axis_text_size = 12,
                 strip_text_size = 12,
                 strip_text_face = "bold"
                 ) + 
  facet_wrap(~question_topic, ncol = 2)

ggsave(here(fig_dir, "m2_perc_fig.png"), width = 8, height = 12, dpi = 300)